#!/usr/bin/env perl
# podwrapper.pl
# @configure_input@
# Copyright (C) 2010-2018 Red Hat Inc.
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are
# met:
#
# * Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
#
# * Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# * Neither the name of Red Hat nor the names of its contributors may be
# used to endorse or promote products derived from this software without
# specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
# THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR
# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
# USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
# OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
# OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
# SUCH DAMAGE.

use warnings;
use strict;

use Pod::Usage;
use Getopt::Long;
use Pod::Man;
use Pod::Simple;
use Pod::Simple::Text;
use Pod::Simple::XHTML;
use File::Basename;

# https://www.redhat.com/archives/libguestfs/2013-May/thread.html#00088
eval { $Text::Wrap::huge = "overflow" };

=head1 NAME

podwrapper.pl - generate documentation from POD input files

=head1 SYNOPSIS

 EXTRA_DIST = foo.pod
 
 if HAVE_POD
 
 man_MANS = foo.1
 CLEANFILES += $(man_MANS)
 
 foo.1: foo.pod
         $(PODWRAPPER) --section 1 --man $@ \
           --html $(top_builddir)/html/$@.html \
           $<
 
 endif HAVE_POD

=head1 DESCRIPTION

podwrapper.pl is a Perl script that generates various output formats
from POD input files that nbdkit uses for most documentation.

You must specify one input file, and one or more output formats.  The
output options are I<--man>, I<--html> and I<--text> (see below).

In C<Makefile.am> files, use a variation of the boilerplate shown in
the L</SYNOPSIS> section above.

For information about the POD format, see L<perlpod(1)>.

=head1 OPTIONS

=over 4

=cut

my $help;

=item B<--help>

Display brief help.

=cut

my $html;

=item B<--html output.html>

Write a web page to C<output.html>.  If this option is not
given, then no web page output is produced.

=cut

my @inserts;

=item B<--insert filename:__PATTERN__>

In the input file, replace the literal text C<__PATTERN__> with the
replacement file C<filename>.  You can give this option multiple
times.

The contents of C<filename> are treated as POD.
Compare and contrast with I<--verbatim>.

Although it is conventional to use C<__...__> (double underscores) for
patterns, in fact you can use any string as the pattern.

=cut

my $man;

=item B<--man output.n>

Write a man page to C<output.n> (C<n> is the manual section number).
If this option is not given, then no man page output is produced.

=cut

my $name;

=item B<--name name>

Set the name of the man page.  If not set, defaults to the basename
of the input file.

=cut

my $section;

=item B<--section N>

Set the section of the man page (a number such as C<1> for
command line utilities or C<3> for C API documentation).  If
not set, defaults to C<1>.

=cut

my $text;

=item B<--text output.txt>

Write a text file to C<output.txt>.  If this option is not
given, then no text output is produced.

=cut

my @verbatims;

=item B<--verbatim filename:__PATTERN__>

In the input file, replace the literal text C<__PATTERN__> with the
replacement file C<filename>.  You can give this option multiple
times.

The contents of C<filename> are inserted as verbatim text, and
are I<not> interpreted as POD.
Compare and contrast with I<--insert>.

Although it is conventional to use C<__...__> (double underscores) for
patterns, in fact you can use any string as the pattern.

=cut

# Clean up the program name.
my $progname = $0;
$progname =~ s{.*/}{};

# Parse options.
GetOptions ("help|?" => \$help,
            "html=s" => \$html,
            "insert=s" => \@inserts,
            "man=s" => \$man,
            "name=s" => \$name,
            "section=s" => \$section,
            "text=s" => \$text,
            "verbatim=s" => \@verbatims,
    ) or pod2usage (2);
pod2usage (1) if $help;

die "$progname: missing argument: podwrapper input.pod\n" unless @ARGV == 1;
my $input = $ARGV[0];

# There should be at least one output.
die "$progname: $input: no output format specified.  Use --man and/or --html and/or --text.\n"
    unless defined $man || defined $html || defined $text;

# Default for $name and $section.
$name = basename ($input, ".pod") unless defined $name;
$section = 1 unless defined $section;

# Note that these @...@ are substituted by ./configure.
my $abs_top_srcdir = "@abs_top_srcdir@";
my $abs_top_builddir = "@abs_top_builddir@";
my $package_name = "@PACKAGE_NAME@";
my $package_version = "@PACKAGE_VERSION@";

die "$progname: ./configure substitutions were not performed"
    unless $abs_top_srcdir && $abs_top_builddir &&
    $package_name && $package_version;

# Create a stable date (thanks Hilko Bengen).
my $date;
my $filename = "$abs_top_srcdir/.git";
if (!$date && -d $filename) {
    local $ENV{GIT_DIR} = $filename;
    $_ = `git show -s --format=%ci`;
    $date = $1 if /^(\d+-\d+-\d+)\s/;
}
if (!$date) {
    my ($day, $month, $year) = (localtime)[3,4,5];
    $date = sprintf ("%04d-%02d-%02d", $year+1900, $month+1, $day);
}

# Create a release string.
my $release = "$package_name-$package_version";

#print "input=$input\n";
#print "name=$name\n";
#print "section=$section\n";
#print "date=$date\n";

# Read the input.
my $content = read_whole_file ($input);

# Perform @inserts.
foreach (@inserts) {
    my @a = split /:/, $_, 2;
    die "$progname: $input: no colon in parameter of --insert\n" unless @a >= 2;
    my $replacement = read_whole_file ($a[0]);
    my $oldcontent = $content;
    $content =~ s/$a[1]/$replacement/ge;
    die "$progname: $input: could not find pattern '$a[1]' in input file\n"
        if $content eq $oldcontent;
}

# Turn external links to this man page into simple cross-section links.
$content =~ s,\QL<$name($section)/\E,L</,g;

# Perform @verbatims.
foreach (@verbatims) {
    my @a = split /:/, $_, 2;
    die "$progname: $input: no colon in parameter of --verbatim\n" unless @a >= 2;
    my $replacement = read_verbatim_file ($a[0]);
    my $oldcontent = $content;
    $content =~ s/$a[1]/$replacement/ge;
    die "$progname: $input: could not find pattern '$a[1]' in input file\n"
        if $content eq $oldcontent;
}

# There should be no =encoding line present in the content (we will add one).
die "$progname: $input: =encoding must not be present in input\n"
    if $content =~ /^=encoding/m;

$content =~ s/^=(.*)/\n=encoding utf8\n\n=$1/m;

# Verify sections present / not present.
die "$progname: $input: missing NAME section\n"
    if $content !~ /^=head1 NAME/m;
die "$progname: $input: missing DESCRIPTION section\n"
    if $content !~ /^=head1 DESCRIPTION/m;
die "$progname: $input: missing AUTHOR or AUTHORS section\n"
    unless $content =~ /^=head1 AUTHOR/m;
die "$progname: $input: missing SEE ALSO section\n"
    unless $content =~ /^=head1 SEE ALSO/m;
die "$progname: $input: missing COPYRIGHT section\n"
    unless $content =~ /^=head1 COPYRIGHT/m;
die "$progname: $input: BUGS is now added automatically, do not add it to the POD file\n"
    if $content =~ /^=head1 (REPORTING )?BUGS/m;
die "$progname: $input: LICENSE is now added automatically, do not add it to the POD file\n"
    if $content =~ /^=head1 LICENSE/m;

# Check NAME section conformity.
my @lines = split /\n/, $content;
my @name;
foreach (@lines) {
    push @name, $_ if /^=head1 NAME/../^=head1 (?!NAME)/
}
shift @name;                    # remove =head1 and empty line
shift @name;                    # from beginning and end
pop @name;
pop @name;
die "$progname: $input: empty NAME section\n"
    unless @name >= 1;
die "$progname: $input: NAME doesn't start with nbdkit\n"
    unless $name[0] =~ m/^nbdkit/;
die "$progname: $input: NAME does not conform with Linux man pages standard\n"
    if $name[0] !~ m/- [a-z]/ || $name[@name-1] =~ m/\.$/;

# Add standard LICENSE section at the end.
$content .=
"

=head1 LICENSE

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

=over 4

=item *

Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.

=item *

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

=item *

Neither the name of Red Hat nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission.

=back

THIS SOFTWARE IS PROVIDED BY RED HAT AND CONTRIBUTORS ''AS IS'' AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL RED HAT OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
SUCH DAMAGE.
";

# Check no over-long lines in the input.  (As a special exception this
# is permitted in verbatim sections or if the line contains a URL).
@lines = split /\n/, $content;
foreach (@lines) {
    die "$progname: $input: line too long:\n$_\n"
        if length $_ > 76 &&
        substr ($_, 0, 1) ne ' ' &&
        ! m/https?:/;
}

# Output man page.
SUBMAN: {
    package Podwrapper::Man;

    use vars qw(@ISA $VERSION);
    @ISA = qw(Pod::Man);
    $VERSION = $package_version;

    # Override the L<> method.
    sub cmd_l
    {
        my ($self, $attrs, $text) = @_;
        return $text;
    }
}

if ($man) {
    my $parser = Podwrapper::Man->new (
        name => $name,
        release => $release, section => $section,
        center => "NBDKIT",
        date => $date,
        stderr => 1, utf8 => 1
    );
    my $output;
    $parser->no_errata_section (1);
    $parser->complain_stderr (1);
    $parser->output_string (\$output);
    $parser->parse_string_document ($content)
        or die "$progname: could not parse input document";
    open OUT, ">$man" or die "$progname: $man: $!";
    print OUT $output or die "$progname: $man: $!";
    close OUT or die "$progname: $man: $!";
    if ($parser->any_errata_seen) {
        unlink $man;
        die "$input: errors or warnings in this POD file, see messages above\n"
    }
    #print "$progname: wrote $man\n";
}

# Output HTML.
SUBHTML: {
    # Subclass Pod::Simple::XHTML.  See the documentation.
    package Podwrapper::XHTML;

    use vars qw(@ISA $VERSION);
    @ISA = qw(Pod::Simple::XHTML);
    $VERSION = $package_version;

    sub is_an_nbdkit_page
    {
        local $_ = shift;

        return 1 if /^nbdkit/;
        return 0;
    }

    sub resolve_man_page_link
    {
        my $self = shift;
        my $name = $_[0];   # eg. "nbdkit(1)", can be undef
        my $anchor = $_[1]; # eg. "SYNOPSIS", can be undef
        my $r = "";
        if (defined $name) {
            return $self->SUPER::resolve_man_page_link (@_)
                unless is_an_nbdkit_page ($name);
            $name =~ s/\((.*)\)$/.$1/;
            $r .= "$name.html";
        }
        $r .= "#" . $self->idify ($anchor, 1) if defined $anchor;
        $r;
    }

    # For some reason Pod::Simple::XHTML usually cannot find a
    # title for the page.  This defaults the HTML <title> field
    # to the same as the man page name.
    sub default_title { $name }
}

if ($html) {
    mkdir "$abs_top_builddir/html";

    my $parser = Podwrapper::XHTML->new;
    my $output;
    $parser->no_errata_section (1);
    $parser->complain_stderr (1);
    $parser->output_string (\$output);
    # Added in Pod::Simple 3.16, 2011-03-14.
    eval { $parser->html_charset ("UTF-8") };
    $parser->html_css ("pod.css");
    $parser->index (1);
    $parser->parse_string_document ($content);

    # Hack for Perl 5.16.
    $output =~ s{/>pod.css<}{/>\n<};

    open OUT, ">$html" or die "$progname: $html: $!";
    print OUT $output or die "$progname: $html: $!";
    close OUT or die "$progname: $html: $!";
    if ($parser->any_errata_seen) {
        unlink $html;
        die "$input: errors or warnings in this POD file, see messages above\n"
    }
    #print "$progname: wrote $html\n";
}

# Output text.
if ($text) {
    my $parser = Pod::Simple::Text->new;
    my $output;
    $parser->no_errata_section (1);
    $parser->complain_stderr (1);
    $parser->output_string (\$output);
    $parser->parse_string_document ($content);
    open OUT, ">$text" or die "$progname: $text: $!";
    binmode OUT, ":utf8";
    print OUT $output or die "$progname: $text: $!";
    close OUT or die "$progname: $text: $!";
    if ($parser->any_errata_seen) {
        unlink $text;
        die "$input: errors or warnings in this POD file, see messages above\n"
    }
    #print "$progname: wrote $text\n";
}

sub read_whole_file
{
    my $input = shift;
    local $/ = undef;

    open FILE, "<:encoding(UTF-8)", $input or die "$progname: $input: $!";
    $_ = <FILE>;
    close FILE;
    $_;
}

sub read_verbatim_file
{
    my $input = shift;
    my $r = "";

    open FILE, "<:encoding(UTF-8)", $input or die "$progname: $input: $!";
    while (<FILE>) {
        $r .= " $_";
    }
    close FILE;
    $r;
}

=head1 SEE ALSO

L<perlpod(1)>,
L<Pod::Simple(3pm)>.

=head1 AUTHOR

Richard W.M. Jones.

=head1 COPYRIGHT

Copyright (C) 2012-2018 Red Hat Inc.
